#  jlibsasl.tcl --
#  
#      This file is part of the jabberlib. It provides support for the
#      SASL authentication layer via the tclsasl or tcllib SASL package.
#      
#  Copyright (c) 2005 Sergei Golovan <sgolovan@nes.ru>
#  Based on jlibsasl by Mats Bengtson
#  
# $Id: jlibsasl.tcl 1244 2007-10-06 07:53:04Z sergei $
#
# SYNOPSIS
#   jlibsasl::new connid args
#	creates auth token
#	args: -sessionid   sessionid
#	      -username    username
#	      -server      server
#	      -resource    resource
#	      -password    password
#	      -allow_plain boolean
#	      -command     callback
#
#   token configure args
#	configures token parameters
#	args: the same as in jlibsasl::new
#
#   token cget arg
#	returns token parameter
#	arg: -sessionid
#	     -username
#	     -server
#	     -resource
#	     -password
#	     -allow_plain
#	     -command
#
#   token auth args
#	starts authenticating procedure
#	args: the same as in jlibsasl::new
#
#   token free
#	frees token resourses

##########################################################################

package require base64
package require namespaces 1.0

package provide jlibsasl 1.0

##########################################################################

namespace eval jlibsasl {
    variable uid 0
    variable saslpack

    if {![catch {package require sasl 1.0}]} {
	set saslpack tclsasl
    } elseif {![catch {package require SASL 1.0}]} {
	catch {package require SASL::NTLM}
	catch {package require SASL::XGoogleToken}
	set saslpack tcllib
    } else {
	return -code error "No SASL package found"
    }

    switch -- $saslpack {
	tclsasl {
	    sasl::client_init -callbacks [list [list log ::LOG]]
	}
	default {
	    # empty
	}
    }

    # SASL error messages
    stanzaerror::register_errortype sasl [::msgcat::mc "Authentication Error"]

    foreach {lcode type cond description} [list \
	401 sasl aborted		[::msgcat::mc "Aborted"] \
	401 sasl incorrect-encoding	[::msgcat::mc "Incorrect encoding"] \
	401 sasl invalid-authzid	[::msgcat::mc "Invalid authzid"] \
	401 sasl invalid-mechanism	[::msgcat::mc "Invalid mechanism"] \
	401 sasl mechanism-too-weak	[::msgcat::mc "Mechanism too weak"] \
	401 sasl not-authorized		[::msgcat::mc "Not Authorized"] \
	401 sasl temporary-auth-failure	[::msgcat::mc "Temporary auth failure"]] \
    {
	stanzaerror::register_error $lcode $type $cond $description
    }
}

##########################################################################

proc jlibsasl::new {connid args} {
    variable uid

    set token [namespace current]::[incr uid]
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::new $connid) $token"

    set state(-connid) $connid
    set state(-allow_plain) 0
    set state(-allow_google_token) 1
    catch {unset state(-mechanisms)}

    proc $token {cmd args} \
	"eval {[namespace current]::\$cmd} {$token} \$args"

    eval [list configure $token] $args

    jlib::register_xmlns $state(-connid) $::NS(sasl) \
	[list [namespace code parse] $token]

    return $token
}

##########################################################################

proc jlibsasl::free {token} {
    variable saslpack
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::free $token)"

    jlib::unregister_xmlns $state(-connid) $::NS(sasl)

    if {[info exists state(-token)]} {
	switch -- $saslpack {
	    tclsasl {
		rename $state(-token) ""
	    }
	    tcllib {
		SASL::cleanup $state(-token)
	    }
	}
    }

    catch {unset state}
    catch {rename $token ""}
}

##########################################################################

proc jlibsasl::configure {token args} {
    variable $token
    upvar 0 $token state

    foreach {key val} $args {
	switch -- $key {
	    -sessionid -
	    -username -
	    -server -
	    -resource -
	    -password -
	    -allow_plain -
	    -allow_google_token -
	    -command {
		set state($key) $val
	    }
	    default {
		return -code error "Illegal option \"$key\""
	    }
	}
    }
}

##########################################################################

proc jlibsasl::cget {token arg} {
    variable $token
    upvar 0 $token state

    switch -- $arg {
	-sessionid -
	-username -
	-server -
	-resource -
	-password -
	-allow_plain -
	-command {
	    if {[info exists state($arg)]} {
		return $state($arg)
	    } else {
		return ""
	    }
	}
	default {
	    return -code error "Illegal option \"$arg\""
	}
    }
}

##########################################################################

proc jlibsasl::parse {token xmldata} {
    variable $token
    upvar 0 $token state

    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children

    switch -- $tag {
	mechanisms {
	    set mechanisms {}
	    foreach child $children {
		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1
		if {$tag1 == "mechanism"} {
		    lappend mechanisms $cdata1
		}
	    }
	    set state(-mechanisms) $mechanisms
	}
	challenge {
	    step $token $cdata
	}
	success {
	    success $token
	}
	failure {
	    failure $token $children
	}
    }
}

##########################################################################

proc jlibsasl::auth {token args} {
    variable saslpack
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::auth $token) start"

    eval [list configure $token] $args

    switch -- $saslpack {
	tclsasl {
	    foreach id {authname pass getrealm cnonce} {
		lappend callbacks \
		    [list $id [list [namespace code tclsasl_callback] \
				    $token]]
	    }

	    set state(-token) \
		[sasl::client_new -service     xmpp \
				  -serverFQDN  $state(-server) \
				  -callbacks   $callbacks \
				  -flags       success_data]

	    if {$state(-allow_plain)} {
		set flags {}
	    } else {
		set flags {noplaintext}
	    }

	    $state(-token) -operation setprop \
			   -property sec_props \
			   -value [list min_ssf 0 \
					max_ssf 0 \
					flags $flags]
	}
	tcllib {
	    set state(-token) \
		[SASL::new -service xmpp \
			   -type client \
			   -server $state(-server) \
			   -callback [list [namespace code tcllib_callback] \
					   $token]]
	    # Workaround a bug 1545306 in tcllib SASL module
	    set ::SASL::digest_md5_noncecount 0
	}
    }

    jlib::trace_stream_features $state(-connid) \
	[list [namespace code auth_continue] $token]
}

##########################################################################

proc jlibsasl::auth_continue {token} {
    variable saslpack
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::auth $token)"
    
    if {![info exists state(-mechanisms)]} {
	finish $token ERR \
	    [concat modify \
		 [stanzaerror::error modify not-acceptable -text \
		      [::msgcat::mc \
			   "Server haven't provided SASL authentication\
			    feature"]]]
	return
    }
    
    ::LOG "(jlibsasl::auth $token) mechs: $state(-mechanisms)"

    switch -- $saslpack {
	tclsasl {
	    set code [catch {
		$state(-token) \
		    -operation start \
		    -mechanisms $state(-mechanisms) \
		    -interact [list [namespace code interact] $token]
	    } result]
	}
	tcllib {
	    set code [catch {choose_mech $token} result]

	    if {!$code} {
		set mech $result
		SASL::configure $state(-token) -mech $mech
		switch -- $mech {
		    PLAIN -
		    X-GOOGLE-TOKEN {
			# Initial responce
			set code [catch {SASL::step $state(-token) ""} result]
			if {!$code} {
			    set output [SASL::response $state(-token)]
			}
		    }
		    default {
			set output ""
		    }
		}
		if {!$code} {
		    set result [list mechanism $mech output $output]
		}
	    }
	}
    }

    ::LOG "(jlibsasl::auth $token) SASL code $code: $result"

    switch -- $code {
	0 - 
	4 {
	    array set resarray $result
	    set data [jlib::wrapper:createtag auth \
			  -vars   [list xmlns $::NS(sasl) \
					mechanism $resarray(mechanism)] \
			  -chdata [base64::encode -maxlen 0 $resarray(output)]]

	    jlib::outmsg [jlib::wrapper:createxml $data] \
		-connection $state(-connid)
	}
	default {
	    set str [format [::msgcat::mc "SASL auth error:\n%s"] $result]
	    finish $token ERR \
		[concat sasl [stanzaerror::error sasl undefined-condition \
				  -text $str]]
	}
    }
}

##########################################################################

proc jlibsasl::choose_mech {token} {
    variable $token
    upvar 0 $token state

    if {$state(-allow_plain)} {
	set forbidden_mechs {}
    } else {
	set forbidden_mechs {PLAIN LOGIN}
    }

    if {!$state(-allow_google_token)} {
	lappend forbidden_mechs X-GOOGLE-TOKEN
    }

    foreach m [SASL::mechanisms] {
	if {[lsearch -exact $state(-mechanisms) $m] >= 0 && \
		[lsearch -exact $forbidden_mechs $m] < 0} {
	    return $m
	}
    }
    if {[llength $state(-mechanisms)] == 0} {
	return -code error [::msgcat::mc "Server provided no SASL mechanisms"]
    } elseif {[llength $state(-mechanisms)] == 1} {
	return -code error [::msgcat::mc "Server provided mechanism\
					  %s. It is forbidden" \
					 [lindex $state(-mechanisms) 0]]
    } else {
	return -code error [::msgcat::mc "Server provided mechanisms\
					  %s. They are forbidden" \
					 [join $state(-mechanisms) ", "]]
    }
}

##########################################################################

proc jlibsasl::step {token serverin64} {
    variable saslpack
    variable $token
    upvar 0 $token state

    set serverin [base64::decode $serverin64]

    switch -- $saslpack {
	tclsasl {
	    set code [catch {
		$state(-token) \
		    -operation step \
		    -input     $serverin \
		    -interact  [list [namespace code interact] $token]
	    } result]
	}
	tcllib {
	    set code [catch {SASL::step $state(-token) $serverin} result]

	    if {!$code} {
		set result [SASL::response $state(-token)]
	    }
	}
    }

    ::LOG "(jlibsasl::step $token) SASL code $code: $result"

    switch -- $code {
	0 -
	4 {
	    set data [jlib::wrapper:createtag response \
			  -vars   [list xmlns $::NS(sasl)] \
			  -chdata [base64::encode -maxlen 0 $result]]

	    jlib::outmsg [jlib::wrapper:createxml $data] \
		-connection $state(-connid)
	}
	default {
	    finish $token ERR \
		[concat sasl \
			[stanzaerror::error sasl undefined-condition \
			     -text [format "SASL step error: %s" $result]]]
	}
    }
}

##########################################################################

proc jlibsasl::tclsasl_callback {token data} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::tclsasl_callback $token) $data"

    array set params $data

    switch -- $params(id) {
        user {
	    # authzid
            return [encoding convertto utf-8 $state(-username)@$state(-server)]
        }
        authname {
	    #username
            return [encoding convertto utf-8 $state(-username)]
        }
        pass {
            return [encoding convertto utf-8 $state(-password)]
        }
        getrealm {
	    return [encoding convertto utf-8 $state(-server)]
        }
	default {
	    return -code error \
		"SASL callback error: client needs to write $params(id)"
	}
    }
}

##########################################################################

proc jlibsasl::tcllib_callback {token stoken command args} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::tcllib_callback $token) $stoken $command"

    switch -- $command {
	login {
	    # authzid
	    return [encoding convertto utf-8 $state(-username)@$state(-server)]
	}
	username {
	    return [encoding convertto utf-8 $state(-username)]
	}
	password {
	    return [encoding convertto utf-8 $state(-password)]
	}
	realm {
	    return [encoding convertto utf-8 $state(-server)]
	}
	hostname {
	    return [info host]
	}
	default {
	    return -code error \
		"SASL callback error: client needs to write $command"
	}
    }
}

##########################################################################

proc jlibsasl::interact {token data} {
    # empty
    ::LOG "(jlibsasl::interact $token) $data"
}

##########################################################################

proc jlibsasl::failure {token children} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::failure $token)"

    set error [lindex $children 0]
    if {$error == ""} {
	set err not-authorized
    } else {
	jlib::wrapper:splitxml $error tag vars empty cdata children
	set err $tag
    }
    finish $token ERR [concat sasl [stanzaerror::error sasl $err]]
}

##########################################################################

proc jlibsasl::success {token} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::success $token)"
    
    # xmpp-core sect 6.2:
    # Upon receiving the <success/> element,
    # the initiating entity MUST initiate a new stream by sending an
    # opening XML stream header to the receiving entity (it is not
    # necessary to send a closing </stream> tag first...
    
    jlib::reset $state(-connid)
    
    jlib::start_stream [jlib::connection_server $state(-connid)] \
		       -xml:lang [jlib::get_lang] -version "1.0" \
		       -connection $state(-connid)
	
    jlib::trace_stream_features $state(-connid) \
	[list [namespace code resource_bind] $token]
}

##########################################################################

proc jlibsasl::resource_bind {token} {
    variable $token
    upvar 0 $token state

    set data [jlib::wrapper:createtag bind \
		  -vars [list xmlns $::NS(bind)] \
		  -subtags [list [jlib::wrapper:createtag resource \
				      -chdata $state(-resource)]]]

    jlib::send_iq set $data \
	-command [list [namespace code send_session] $token] \
	-connection $state(-connid)
    
}

##########################################################################

proc jlibsasl::send_session {token res xmldata} {
    variable $token
    upvar 0 $token state

    switch -- $res {
	OK {
	    # Decompose returned JID
	    jlib::wrapper:splitxml $xmldata tag vars isempty cdata children
	    foreach child $children {
		jlib::wrapper:splitxml $child tag1 vars1 isempty1 cdata1 children1

		switch -- $tag1 {
		    jid {
			if {[regexp {([^@]*)@([^/]*)/(.*)} $cdata1 -> \
				 username server resource]} {
			    set state(-username) $username
			    set state(-server) $server
			    set state(-resource) $resource
			}
		    }
		}
	    }
	    # Establish the session.
	    set data [jlib::wrapper:createtag session \
			  -vars [list xmlns $::NS(session)]]

	    jlib::send_iq set $data \
		-command [list [namespace code finish] $token] \
		-connection $state(-connid)
	}
	default {
	    ::LOG "error (jlibsasl::send_session) $xmldata"
	    finish $token $res $xmldata
	}
    }
}

##########################################################################

proc jlibsasl::finish {token res child} {
    variable $token
    upvar 0 $token state

    ::LOG "(jlibsasl::finish $token) $res"

    if {$res != "OK"} {
	jlib::client status [::msgcat::mc "Authentication failed"]
    } else {
	jlib::client status [::msgcat::mc "Authentication successful"]
    }
    if {[info exists state(-command)]} {
	uplevel #0 $state(-command) [list $res $child]
    }
}

##########################################################################

